home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Chip 1996 September
/
CHIP 1996 szeptember (CD07).zip
/
CHIP_CD07.ISO
/
sac
/
pack
/
vbdlh02.exe
/
VBDE_SRC.LZH
/
VBDEDIR.FRM
< prev
next >
Wrap
Text File
|
1996-03-08
|
13KB
|
393 lines
VERSION 2.00
Begin Form frmDirList
BackColor = &H8000000F&
BorderStyle = 3 'Fixed Double
Caption = "Directory"
ClientHeight = 5385
ClientLeft = 465
ClientTop = 1770
ClientWidth = 5550
Height = 5760
Left = 420
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5385
ScaleWidth = 5550
Top = 1440
Width = 5640
Begin CheckBox chkDir
Caption = "Over&write"
Height = 375
Index = 1
Left = 3240
TabIndex = 8
Top = 2520
Value = 1 'Checked
Width = 2055
End
Begin Frame fraDirList
Caption = "&Type"
Height = 1335
Left = 3240
TabIndex = 9
Top = 3000
Width = 2055
Begin OptionButton optFile
Caption = "All Files"
Height = 375
Index = 1
Left = 120
TabIndex = 11
Top = 840
Width = 1335
End
Begin OptionButton optFile
Caption = "Selected Files"
Height = 375
Index = 0
Left = 120
TabIndex = 10
Top = 360
Value = -1 'True
Width = 1335
End
End
Begin CheckBox chkDir
Caption = "&Use Directories"
Height = 375
Index = 0
Left = 3240
TabIndex = 7
Top = 2040
Value = 1 'Checked
Width = 2055
End
Begin CommandButton cmdDirList
Caption = "&Make Dir..."
Height = 495
Index = 3
Left = 3240
TabIndex = 12
Top = 4560
Width = 2055
End
Begin CommandButton cmdDirList
Caption = "&Help"
Height = 495
Index = 2
Left = 3240
TabIndex = 6
Top = 1440
Width = 2055
End
Begin CommandButton cmdDirList
Cancel = -1 'True
Caption = "&Cancel"
Height = 495
Index = 1
Left = 3240
TabIndex = 5
Top = 840
Width = 2055
End
Begin CommandButton cmdDirList
Caption = "&OK"
Default = -1 'True
Height = 495
Index = 0
Left = 3240
TabIndex = 4
Top = 240
Width = 2055
End
Begin DriveListBox drvUnpack
Height = 390
Left = 240
TabIndex = 3
Top = 4680
Width = 2775
End
Begin DirListBox dirUnpack
Height = 3330
Left = 240
TabIndex = 1
Top = 960
Width = 2775
End
Begin Label lblPath
AutoSize = -1 'True
BackColor = &H8000000F&
BackStyle = 0 'Transparent
Caption = "Path"
Height = 270
Left = 240
TabIndex = 13
Top = 600
Width = 420
End
Begin Label lblDirlist
AutoSize = -1 'True
BackColor = &H8000000F&
BackStyle = 0 'Transparent
Caption = "Dri&ve:"
Height = 195
Index = 1
Left = 240
TabIndex = 2
Top = 4320
Width = 525
End
Begin Label lblDirlist
AutoSize = -1 'True
BackColor = &H8000000F&
BackStyle = 0 'Transparent
Caption = "&Directory:"
Height = 195
Index = 0
Left = 240
TabIndex = 0
Top = 240
Width = 840
End
End
'===================================================
'Sample VB program using UNLHA.DLL
'VBDeDir.Frm (frmDirList)
'Original: Niiyama(HEROPA) SGV00153@niftyserve.or.jp
'English : Hitoshi Ozawa h_ozawa@bekkoame.or.jp
'===================================================
Option Explicit
Dim mstrUnpackDir As String
Const BTN_OK = 0
Const BTN_CANCEL = 1
Const BTN_HELP = 2
Const BTN_MKDIR = 3
Sub cmdDirList_Click (Index As Integer)
Dim intReturnCode As Integer 'WinHelp return codel
Select Case Index
Case BTN_OK
If Right$(mstrUnpackDir$, 1) <> "\" Then mstrUnpackDir$ = mstrUnpackDir$ & "\"
gstrUnpackDir$ = mstrUnpackDir$
gintfUnpackCancel% = False
gintbDirFlag% = CInt(chkDir(0).Value) * (-1)
gintbOverWriteFalg% = CInt(chkDir(1).Value) * (-1)
Me.Hide
Case BTN_CANCEL
gstrUnpackDir$ = ""
gintfUnpackCancel% = True
Unload Me
Case BTN_HELP
intReturnCode% = WinHelp(frmArchive.hWnd, gstrHelpFile$, HELP_CONTEXT, ByVal HLP_DLGCHOOSEDIR&)
Case BTN_MKDIR
Call MakeDir
End Select
End Sub
Sub dirUnpack_Change ()
mstrUnpackDir$ = dirUnpack.Path
If Me.TextWidth(mstrUnpackDir$) >= dirUnpack.Width Then
lblPath.Caption = GetShortName(mstrUnpackDir$)
Else
lblPath.Caption = mstrUnpackDir$
End If
End Sub
Sub drvUnpack_Change ()
Dim strErrMsg As String
Dim intType As Integer
Dim intReturnCode As Integer
On Error GoTo ErrDriveChange:
dirUnpack.Path = drvUnpack.Drive
Exit Sub
ErrDriveChange:
Select Case Err
Case 68 'Device not ready
strErrMsg$ = "Drive" & drvUnpack.Drive & " is not ready."
intType% = MB_RETRYCANCEL Or MB_ICONEXCLAMATION
intReturnCode% = MsgBox(strErrMsg$, intType%, APP_CAPTION)
If intReturnCode% = IDRETRY Then
Resume
End If
Case Else
MsgBox "Unpredicted error. Err:" & Err
End Select
'Return drive
drvUnpack.Drive = dirUnpack.Path
Resume Next
End Sub
Sub Form_Load ()
Dim intLoopCount As Integer
Dim intbSelectFlag As Integer
Call SetControlPosition
Call SetControl3D
'Check if List box was selected
intbSelectFlag% = False
For intLoopCount% = 0 To frmArchive!lstArchive.ListCount - 1
If frmArchive!lstArchive.Selected(intLoopCount%) = True Then
intbSelectFlag% = True
End If
Next intLoopCount%
'if selected
If intbSelectFlag% = True Then
optFile(0).Value = True
optFile(1).Value = False
'if not selected
Else
optFile(1).Value = True
optFile(0).Value = False
optFile(1).Enabled = False
optFile(0).Enabled = False
fraDirList.Enabled = False
End If
'Recurse Directory option
If gintbDirFlag% = True Then
chkDir(0).Value = CHECKED
Else
chkDir(0).Value = UNCHECKED
End If
'Overwrite option
If gintbOverWriteFalg% = True Then
chkDir(1).Value = CHECKED
Else
chkDir(1).Value = UNCHECKED
End If
mstrUnpackDir$ = LCase$(gstrUnpackDir$)
dirUnpack.Path = mstrUnpackDir$
drvUnpack.Drive = mstrUnpackDir$
If Me.TextWidth(mstrUnpackDir$) >= dirUnpack.Width Then
lblPath.Caption = GetShortName(mstrUnpackDir$)
Else
lblPath.Caption = mstrUnpackDir$
End If
Call SetChildWindowPos(frmArchive, Me)
Call DeleteSwitchTo(Me)
Me.Icon = frmArchive.Icon
Me.Caption = APP_CAPTION & " - " & Me.Caption
'If help file does not exist
If gstrHelpFile$ = "" Then cmdDirList(BTN_HELP).Enabled = False
End Sub
'display InputBox and create directory based on input
Sub MakeDir ()
Dim strReturnStrings As String 'InputBox return code
Dim strMsg As String 'MsgBox
Dim intType As Integer 'MsgBox
Dim strMakePath As String 'make directory
strMsg$ = "Please enter directory name below " & dirUnpack.Path & "."
strReturnStrings$ = Trim(InputBox(strMsg$, "Make Dir"))
If strReturnStrings$ = "" Then Exit Sub
On Error GoTo ErrInput
strMakePath$ = dirUnpack.Path
If Right$(strMakePath$, 1) <> "\" Then strMakePath$ = strMakePath$ & "\"
MkDir strMakePath$ & strReturnStrings$
dirUnpack.Path = strMakePath$ & strReturnStrings$
Exit Sub
ErrInput:
Select Case Err
Case 75 'directory already exists
strMsg$ = strReturnStrings$ & " already exists. Extract files there?"
intType% = MB_YESNO Or MB_ICONQUESTION
If MsgBox(strMsg$, intType%, APP_CAPTION) = IDYES Then
Resume Next
End If
Case Else
strMsg$ = "Failed to make directory " & strReturnStrings$ & ". MakeDirErr: " & Err
MsgBox strMsg, MB_ICONEXCLAMATION, APP_CAPTION
Exit Sub
End Select
Resume
End Sub
'draw 3D objects about controls
Sub SetControl3D ()
Me.AutoRedraw = True
Call Draw3DControl(dirUnpack)
Call Draw3DControl(drvUnpack)
Call Draw3DForm(Me)
Me.AutoRedraw = False
End Sub
'set control position
Sub SetControlPosition ()
Const DLG_SPACE = 4
dirUnpack.Width = Me.TextWidth(String$(15, "A"))
lblDirList(0).Left = 2 * DLG_SPACE * Screen.TwipsPerPixelX
lblDirList(0).Top = 2 * DLG_SPACE * Screen.TwipsPerPixelY
lblPath.Left = lblDirList(0).Left
lblPath.Top = lblDirList(0).Top + lblDirList(0).Height + DLG_SPACE * Screen.TwipsPerPixelY
cmdDirList(0).Left = dirUnpack.Left + dirUnpack.Width + 2 * DLG_SPACE * Screen.TwipsPerPixelX
cmdDirList(0).Top = lblDirList(0).Top
cmdDirList(0).Width = Me.TextWidth("Dirì∞ɼ(M)...") + 3 * DLG_SPACE * Screen.TwipsPerPixelX
cmdDirList(0).Height = Me.TextHeight("OK") + 3 * DLG_SPACE * Screen.TwipsPerPixelY
cmdDirList(1).Left = cmdDirList(0).Left
cmdDirList(1).Top = cmdDirList(0).Top + cmdDirList(0).Height + DLG_SPACE * Screen.TwipsPerPixelY
cmdDirList(1).Width = cmdDirList(0).Width
cmdDirList(1).Height = cmdDirList(0).Height
cmdDirList(2).Left = cmdDirList(1).Left
cmdDirList(2).Top = cmdDirList(1).Top + cmdDirList(1).Height + DLG_SPACE * Screen.TwipsPerPixelY
cmdDirList(2).Width = cmdDirList(1).Width
cmdDirList(2).Height = cmdDirList(1).Height
chkDir(0).Left = cmdDirList(2).Left
chkDir(0).Top = cmdDirList(2).Top + cmdDirList(2).Height + DLG_SPACE * Screen.TwipsPerPixelY
chkDir(0).Width = cmdDirList(2).Width
chkDir(0).Height = Me.TextHeight("DirùLî°") + DLG_SPACE * Screen.TwipsPerPixelY
chkDir(0).BackColor = Me.BackColor
chkDir(1).Left = chkDir(0).Left
chkDir(1).Top = chkDir(0).Top + chkDir(0).Height + DLG_SPACE * Screen.TwipsPerPixelY
chkDir(1).Width = chkDir(0).Width
chkDir(1).Height = chkDir(0).Height
chkDir(1).BackColor = Me.BackColor
fraDirList.Left = chkDir(1).Left
fraDirList.Top = chkDir(1).Top + chkDir(1).Height + DLG_SPACE * Screen.TwipsPerPixelY
fraDirList.Width = chkDir(1).Width
fraDirList.Height = 4 * Me.TextHeight("æ╬Å█") + 3 * DLG_SPACE * Screen.TwipsPerPixelY
fraDirList.BackColor = Me.BackColor
optFile(0).Left = 2 * DLG_SPACE * Screen.TwipsPerPixelX
optFile(0).Top = Me.TextHeight("æ╬Å█") + 2 * DLG_SPACE * Screen.TwipsPerPixelY
optFile(0).Width = fraDirList.Width - 4 * DLG_SPACE * Screen.TwipsPerPixelX
optFile(0).Height = Me.TextHeight("æ╬Å█") + DLG_SPACE * Screen.TwipsPerPixelY
optFile(0).BackColor = Me.BackColor
optFile(1).Left = optFile(0).Left
optFile(1).Top = optFile(0).Top + optFile(0).Height + DLG_SPACE * Screen.TwipsPerPixelY
optFile(1).Width = optFile(0).Width
optFile(1).Height = optFile(0).Height
optFile(1).BackColor = Me.BackColor
cmdDirList(3).Left = fraDirList.Left
cmdDirList(3).Top = fraDirList.Top + fraDirList.Height + DLG_SPACE * Screen.TwipsPerPixelY
cmdDirList(3).Width = cmdDirList(2).Width
cmdDirList(3).Height = cmdDirList(2).Height
drvUnpack.Left = lblDirList(0).Left
drvUnpack.Top = cmdDirList(3).Top + cmdDirList(3).Height - drvUnpack.Height
drvUnpack.Width = dirUnpack.Width
lblDirList(1).Left = drvUnpack.Left
lblDirList(1).Top = drvUnpack.Top - lblDirList(1).Height - DLG_SPACE * Screen.TwipsPerPixelY
dirUnpack.Left = lblDirList(0).Left
dirUnpack.Top = lblPath.Top + lblPath.Height + DLG_SPACE * Screen.TwipsPerPixelY
dirUnpack.Height = lblDirList(1).Top - dirUnpack.Top - DLG_SPACE * Screen.TwipsPerPixelY
Me.Width = cmdDirList(3).Left + cmdDirList(3).Width + (2 * DLG_SPACE + 2 * gintCXDLGFRAME + 2) * Screen.TwipsPerPixelX
Me.Height = cmdDirList(3).Top + cmdDirList(3).Height + (2 * DLG_SPACE + 2 * gintCYDLGFRAME + gintCYCAPTION + 2) * Screen.TwipsPerPixelY
End Sub